home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istpf / ISTPF.MAC.f next >
Encoding:
Text File  |  1989-03-04  |  9.9 KB  |  276 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.3
  3. C---------------------------------------------------------
  4. C ======================================================================
  5. C
  6. C       I S T P F   -   Main program for Toolpack/1 PFORT-77
  7. C
  8. C       Programmed by: Malcolm Cohen, NAG Central Office, 1986.
  9. C
  10. C ======================================================================
  11. C
  12. C       Basic Program Structure:
  13. C       ------------------------
  14. C
  15. C                            +-------+
  16. C                            | ISTPF |
  17. C                            +---+---+
  18. C                                |
  19. C     +---------------+----------+------+------------+------------+
  20. C     |               |                 |            |            |
  21. C     |          +PFLIB1.MAC+       PFLIB2.MAC   PFLIB3.MAC   PFLIB4.MAC
  22. C     |          |          |           |            |            |
  23. C +---+----+ +---+----+ +---+----+  +---+----+   +---+----+   +---+----+
  24. C | PFARGS | | PFINIT | | PFCHKL |  | PFREAD |   | PFCONS |   | PFCHKS |
  25. C +--------+ +--------+ +--------+  +---+----+   +---+----+   +---+----+
  26. C                           |           |            |            |
  27. C                          ...         ...          ...          ...
  28. C                          ------low-level processing routines------
  29. C
  30. C Thus, we note: (1) All PFORT-77 checking is done in PFLIB1-4, each of
  31. C                    which contains the code for one phase of PFORT-77.
  32. C                (2) The interface to the checking routines is:
  33. C                       PFINIT - must be called first.
  34. C                       PFCHKL - performs local checking.
  35. C                       PFREAD - read PFORT77 data from attribute area,
  36. C                                this must be done for each attribute
  37. C                                file to be processed.
  38. C                       PFCONS - construct PFORT77 data structures,
  39. C                                this must be done after all attribute
  40. C                                information has been read in.
  41. C                       PFCHKS - check the program representation,
  42. C                                this must be done at the end.
  43. C                (3) An error found in one phase will generally preclude
  44. C                    successful operation of following phases.
  45. C
  46.  
  47.         PROGRAM ISTPF
  48.  
  49.         CHARACTER*(*) ABTMES
  50.         PARAMETER (ABTMES='ISTPF aborted...')
  51.  
  52.         INTEGER TREPTH(81),SYMPTH(81),ATRPTH(81),
  53.      +          LIBPTH(81),IODREF,IODTRE,IODSYM,IODATR,IODLIB,
  54.      +          NERROR,NWARN,STATUS,I
  55.         LOGICAL REFFIL
  56.  
  57.         INTEGER GETARG,OPEN,LENGTH,ZGTCMD
  58.         EXTERNAL ZINIT,GETARG,ZQUIT,ZYINPT,ZYINSY,CLOSE,OPEN,REMARK,
  59.      +           ZMESS,ZYXRAB,ERROR,CANT,ZPTINT,ZCHOUT,LENGTH
  60.  
  61.         CALL ZINIT
  62.  
  63.         CALL ZMESS('ISTPF - Toolpack/1 PFORT-77 Portability Verifier',
  64.      +             1)
  65.  
  66.         IF (GETARG(1,TREPTH,81).EQ.-100) CALL PFARGS(TREPTH,1)
  67.  
  68.         NERROR=0
  69.         NWARN=0
  70.  
  71.         REFFIL=TREPTH(1).EQ.40
  72.         IF (REFFIL) THEN
  73.             TREPTH(LENGTH(TREPTH))=129
  74.             IODREF=OPEN(TREPTH(2),0)
  75.             IF (IODREF.EQ.-1) THEN
  76.                 CALL CANT(TREPTH(2))
  77.                 CALL ERROR(ABTMES)
  78.             END IF
  79.             IF (IODREF.EQ.0) THEN
  80.                 CALL ZMESS('Input filenames, end with bl'//'ank line',
  81.      +                     1)
  82.                 CALL PFARGS(TREPTH,1)
  83.                 CALL PFARGS(SYMPTH,2)
  84.                 CALL PFARGS(ATRPTH,3)
  85.             ELSE
  86.                 IF (ZGTCMD(TREPTH,IODREF).LE.0)
  87.      +              CALL ERROR('Can''t re'//'ad reference file')
  88.                 IF (ZGTCMD(SYMPTH,IODREF).LE.0)
  89.      +              CALL ERROR('Can''t re'//'ad reference file')
  90.                 IF (ZGTCMD(ATRPTH,IODREF).LE.0)
  91.      +              CALL ERROR('Can''t re'//'ad reference file')
  92.             END IF
  93.         ELSE
  94.             IF (GETARG(2,SYMPTH,81).EQ.-100) CALL PFARGS(SYMPTH,2)
  95.             IF (GETARG(3,ATRPTH,81).EQ.-100) CALL PFARGS(ATRPTH,3)
  96.         END IF
  97.         CALL PFINIT
  98.  100    IF (TREPTH(1).NE.129) THEN
  99.             IODTRE=OPEN(TREPTH,0)
  100.             IF (IODTRE.EQ.-1) THEN
  101.                 CALL CANT(TREPTH)
  102.                 CALL ERROR(ABTMES)
  103.             END IF
  104.             IODSYM=OPEN(SYMPTH,0)
  105.             IF (IODSYM.EQ.-1) THEN
  106.                CALL CANT(SYMPTH)
  107.                CALL ERROR(ABTMES)
  108.             END IF
  109.             IODATR=OPEN(ATRPTH,0)
  110.             IF (IODATR.EQ.-1) THEN
  111.                 CALL CANT(ATRPTH)
  112.                 CALL ERROR(ABTMES)
  113.             END IF
  114.             CALL ZYINPT(IODTRE)
  115.             CALL CLOSE(IODTRE)
  116.             CALL ZYINSY(IODSYM)
  117.             CALL CLOSE(IODSYM)
  118.             CALL ZYXRAB(IODATR)
  119.             CALL CLOSE(IODATR)
  120.             CALL PFCHKL(NERROR,NWARN)
  121.             CALL PFREAD
  122.             IF (REFFIL) THEN
  123.                 IF (IODREF.EQ.0) THEN
  124.                     CALL PFARGS(TREPTH,1)
  125.                     IF (TREPTH(1).NE.129) THEN
  126.                         CALL PFARGS(SYMPTH,2)
  127.                         CALL PFARGS(ATRPTH,3)
  128.                         GOTO 100
  129.                     END IF
  130.                 ELSE IF (ZGTCMD(TREPTH,IODREF).GT.0) THEN
  131.                     IF (ZGTCMD(SYMPTH,IODREF).LE.0)
  132.      +                  CALL ERROR('Error in reference file')
  133.                     IF (ZGTCMD(ATRPTH,IODREF).LE.0)
  134.      +                  CALL ERROR('Error in reference file')
  135.                     GOTO 100
  136.                 END IF
  137.             END IF
  138.         END IF
  139.  
  140.         IF (NERROR.GT.0) CALL REMARK(
  141.      +'Program has errors - proceeding with global analysis')
  142.         CALL CLOSE(IODREF)
  143.  
  144.         I=4
  145.         LIBPTH(2)=129
  146.  200    IF (GETARG(I,LIBPTH,81).NE.-100) THEN
  147.             IF (LIBPTH(1).NE.45 .OR. LIBPTH(2).NE.129) THEN
  148.                 IF (LIBPTH(1).NE.40) THEN
  149.                     IODLIB=OPEN(LIBPTH,0)
  150.                     IF (IODLIB.EQ.-1) THEN
  151.                         CALL CANT(LIBPTH)
  152.                         CALL ERROR('ISTPF aborted...')
  153.                     END IF
  154.                     CALL ZYXRAB(IODLIB)
  155.                     CALL CLOSE(IODLIB)
  156.                     CALL PFREAD
  157.                 ELSE
  158.                     LIBPTH(LENGTH(LIBPTH)) = 129
  159.                     IODREF=OPEN(LIBPTH(2),0)
  160.                     IF (IODREF.EQ.-1) THEN
  161.                         CALL CANT(LIBPTH(2))
  162.                         CALL ERROR('ISTPF aborted...')
  163.                     ENDIF
  164.  250                IF (ZGTCMD(LIBPTH,IODREF).GT.0) THEN
  165.                         IODLIB=OPEN(LIBPTH,0)
  166.                         IF (IODLIB.EQ.-1) THEN
  167.                             CALL CANT(LIBPTH)
  168.                         ELSE
  169.                             CALL ZYXRAB(IODLIB)
  170.                             CALL CLOSE(IODLIB)
  171.                             CALL PFREAD
  172.                         END IF
  173.                         GOTO 250
  174.                     END IF
  175.                     CALL CLOSE(IODREF)
  176.                 END IF
  177.                 I=I+1
  178.                 IF (I.LE.10) GOTO 200
  179.             END IF
  180.         ELSE IF (I.EQ.4) THEN
  181.             CALL ZMESS('Input library files, end with bl'//'ank line',
  182.      +                 1)
  183.  300        CALL PFARGS(LIBPTH,4)
  184.             IF (LIBPTH(1).NE.129) THEN
  185.                 IF(LIBPTH(1).NE.40) THEN
  186.                     IODLIB=OPEN(LIBPTH,0)
  187.                     IF (IODLIB.EQ.-1) THEN
  188.                         CALL CANT(LIBPTH)
  189.                     ELSE
  190.                         CALL ZYXRAB(IODLIB)
  191.                         CALL CLOSE(IODLIB)
  192.                         CALL PFREAD
  193.                     END IF
  194.                 ELSE
  195.                     LIBPTH(LENGTH(LIBPTH)) = 129
  196.                     IODREF=OPEN(LIBPTH(2),0)
  197.                     IF (IODREF.EQ.-1) THEN
  198.                         CALL CANT(LIBPTH)
  199.                         CALL ERROR('ISTPF aborted...')
  200.                     ENDIF
  201.  350                IF (ZGTCMD(LIBPTH,IODREF).GT.0) THEN
  202.                         IODLIB=OPEN(LIBPTH,0)
  203.                         IF (IODLIB.EQ.-1) THEN
  204.                             CALL CANT(LIBPTH)
  205.                         ELSE
  206.                             CALL ZYXRAB(IODLIB)
  207.                             CALL CLOSE(IODLIB)
  208.                             CALL PFREAD
  209.                         END IF
  210.                         GOTO 350
  211.                     END IF
  212.                     CALL CLOSE(IODREF)
  213.                 END IF
  214.                 GOTO 300
  215.             END IF
  216.         END IF
  217.  
  218.         CALL PFCONS
  219.         CALL PFCHKS(NERROR,NWARN)
  220.  
  221.         IF (NERROR.GT.0) THEN
  222.             CALL ZCHOUT('[ISTPF Terminated, ',2)
  223.             CALL ZPTINT(NERROR,1,2)
  224.             IF (NERROR.EQ.1) THEN
  225.                 CALL ZCHOUT(' er'//'ror o'//'r unsafe reference',2)
  226.             ELSE
  227.                 CALL ZCHOUT(' errors o'//'r unsafe references',2)
  228.             END IF
  229.             CALL ZMESS(' detected]',2)
  230.             CALL ZQUIT(-1)
  231.         ELSE IF (NWARN.GT.0) THEN
  232.             CALL ZMESS('[ISTPF Terminated, Warnings produced]',2)
  233.             CALL ZQUIT(-1002)
  234.         ELSE
  235.             CALL ZMESS('[ISTPF Normal Termination]',2)
  236.             CALL ZQUIT(-2)
  237.         END IF
  238.  
  239.         END
  240. C ----------------------------------------------------------------------
  241. C
  242. C       P F A R G S   -   Prompt user for arguments to PF tool
  243. C
  244.  
  245.         SUBROUTINE PFARGS(PATH,NUMBER)
  246.         INTEGER PATH(*),NUMBER
  247.  
  248.         INTEGER PROMPT(25,4),I
  249.  
  250.         SAVE PROMPT
  251.  
  252.         INTEGER ZGTCMD
  253.         EXTERNAL ZGTCMD,ZPRMPT,ERROR
  254.  
  255. C "Input parse tree: "
  256. C "Input symbol table: "
  257. C "Attribute file: "
  258. C "Library attribute file: "
  259.  
  260.         DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
  261.      +97,114,115,101,32,116,114,101,101,58,32,129/,
  262.      +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
  263.      +121,109,98,111,108,32,116,97,98,108,101,58,
  264.      +32,129/,
  265.      +       (PROMPT(I,3),I=1,17)/65,116,116,114,105,98,117,
  266.      +116,101,32,102,105,108,101,58,32,129/,
  267.      +       (PROMPT(I,4),I=1,25)/76,105,98,114,97,114,121,
  268.      +32,97,116,116,114,105,98,117,116,101,32,102,
  269.      +105,108,101,58,32,129/
  270.  
  271.         CALL ZPRMPT(PROMPT(1,NUMBER))
  272.         IF (ZGTCMD(PATH,0).EQ.-1)
  273.      +      CALL ERROR('ZGTCMD returned Error status')
  274.  
  275.         END
  276.